perm filename RVRS.F4[MSS,LCS]1 blob
sn#186053 filedate 1975-11-11 generic text, type T, neo UTF8
00100 SUBROUTINE RVRS(IT)
00200 COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1)
00300 K=1
00400
00500 1 J=KPN(K)
00600 R=Q(J+1)
00700 IF(R.NE.1)GO TO 2
00800 C JUMP IF NOT A NOTE
00900 IF(Q(J+5).LT.10)GO TO 10
01000 C JUMP IF NO STEM ON IT
01100 KK=K+1
01200 3 IF(KK.GT.IT)RETURN
01300 JJ=KPN(KK)
01400 RR=Q(JJ+1)
01500 IF(RR.NE.1)GO TO 5
01600 C JUMP IF NOT A NOTE
01700 IF(Q(JJ+5).GE.10)GO TO 6
01800 C SKIP CHORD NOTES (NO STEM)
01900 7 KK=KK+1
02000 GO TO 3
02100 C DID NOT FIND BEAM NEARBY
02200 6 RZ=AMOD(Q(J+4),100.0)
02300 N=J+5
02400 A=10
02500 IF(RZ.GE.7)GO TO 60
02510 IF(Q(N).LT.20)GO TO 10
02515 C NOW STEM SHOULD BE DOWN IF WITHOUT BEAM OR 1ST NT UNDER BEAM.
02520 A=-A
02530 GO TO 15
02700 60 IF(Q(N).GE.20)GO TO 10
02710 C THERE MUST BE A BETTER WAY!
02800 15 Q(N)=Q(N)+A
02900 GO TO 10
03000 8 IF(Q(N).LT.20)GO TO 10
03100 A=-A
03200 C STEM UP
03300 GO TO 15
03400 5 IF(RR.NE.6)GO TO 6
03500 20 B=Q(JJ+4)
03600 C=Q(JJ+5)
03700 D=(B+C)/2.
03800 IF(RR.EQ.5)GO TO 9
03900 IF(RR.NE.6)GO TO 10
04000 B=Q(JJ+6)+1.
04050 C SAVES RANGE OF BEAM +1.
04100 IF(Q(JJ+7).GE.20)GO TO 11
04200 C NOW STEMS ARE UP
04300 IF(D.LE.7)GO TO 12
04400 C JUMP TO 12 IF ALL OK
04500 CC C=-10
04600 GO TO 23
04700 11 IF(D.GT.7.)GO TO 12
04800 C STEMS DOWN
04900 C JUMP IF NO REVERSE NEEDED
05000 23 DO 16 N=K,IT
05100 KK=KPN(N)
05200 IF(Q(KK+3).GT.B)GO TO 14
05300 R=Q(KK+1)
05400 IF(R.NE.1)GO TO 17
05500 L=5
05520 R=Q(KK+8)
05540 C THE STEM LENGTH
05560 IF(R.EQ.999)GO TO 19
05580 Q(KK+8)=-R
05600 C FOR THE INVERSION
05700 19 C=10.
05710 A=Q(KK+L)
05800 IF(A.GE.20)C=-C
05900 Q(KK+L)=C+A
06000 GO TO 16
06100 17 IF(R.NE.6)GO TO 18
06200 C NOW IT'S A BEAM
06300 L=7
06400 GO TO 19
06500 18 IF(R.NE.5)GO TO 16
06600 C NOW IT'S A SLUR
06610 C=-3.5
06620 IF(Q(KK+7))C=-C
06640 CALL SLRV(KK,C)
06650 C TO REVERSE SLUR
06700 CC Q(KK+7)=-Q(KK+7)
06800 16 CONTINUE
06900 C SHOULD ALWAYS EXIT FROM LOOP BEFORE END OF ARRAY!
07000
07100
07200 C NEXT FOR SLURS
07400 9 B=-3.5
07500 IF(Q(JJ+7))GO TO 24
07600 IF(D.GT.7)GO TO 10
07700 C JUMP TO LEAVE STEM UP
07800 GO TO 25
07900 24 IF(D.LT.5)GO TO 10
08000 C JUMP TO LEAVE STEM DOWN
08100 B=-B
08200 CC25 Q(JJ+4)=Q(JJ+4)+B
08300 CC Q(JJ+5)=Q(JJ+5)+B
08400 CC Q(JJ+7)=-R
08410 25 CALL SLRV(JJ,B)
08500 GO TO 10
08600 12 DO 13 N=K+1,IT
08700 KK=KPN(N)
08800 13 IF(Q(KK+3).GT.B)GO TO 14
08900 C JUMP OUT WHEN PAST END OF BEAM.
09000 14 K=N-1
09100 GO TO 10
09200
09300 2 IF(R.NE.6)GO TO 21
09400 22 JJ=J
09500 RR=R
09600 GO TO 20
09700 21 IF(R.EQ.5)GO TO 22
09800 10 IF(K.GT.IT)RETURN
09900 K=K+1
10000 GO TO 1
10100 END